home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Purity / Purity #52 (1995-10-30)(PackMAN)(DE)[WB, FFS].zip / Purity #52 (1995-10-30)(PackMAN)(DE)[WB, FFS].adf / OS2Unit / OS2Unit.p < prev    next >
Text File  |  1995-09-17  |  11KB  |  427 lines
  1. UNIT OS2;
  2.  
  3. {** OS2-Unit, (C) 1995 by Björn Schotte
  4.  **
  5.  ** GIFTWARE
  6.  **
  7.  **
  8.  ** Björn Schotte
  9.  ** Am Burkardstuhl 45
  10.  ** D-97267 Himmelstadt
  11.  ** (Rückporto nicht vergessen!)
  12.  **
  13.  **
  14.  ** EMail: bjoern@bomber.mayn.sub.de
  15.  **
  16.  **
  17.  ** Pascal-FTP-Server: ftp@bomber.mayn.sub.de
  18.  ** (Subject/Body: HELPALL)
  19.  **
  20.  **}
  21.  
  22. INTERFACE
  23.  
  24. USES Intuition, Exec;
  25.  
  26. {$incl "gadtools.lib",
  27.         "graphics/text.h",
  28.          "asl.lib",
  29.          "dos.lib"}
  30.  
  31. CONST
  32.   FREQ_NOTALLOC = -100;
  33.         
  34. TYPE
  35.   p_ASLFileStruct = ^ASLFileStruct;
  36.   ASLFileStruct = RECORD
  37.      left, top,
  38.       width,
  39.       height     : INTEGER;
  40.      titel      : STRING[80];
  41.       pfad,
  42.       datei,
  43.       initp,
  44.       initd,
  45.       filename   : STRING[256];
  46.       pattern    : STRING[80];
  47.       display_pat: BOOLEAN;
  48.       win        : p_Window;
  49.       winsleep,
  50.       canceled   : BOOLEAN;
  51.       negativ,
  52.       positiv    : STRING;
  53.   END;
  54.  
  55. VAR
  56.   topaz80                        : TextAttr;
  57.   MyTattr                  : ^TextAttr;
  58.   WBRight, WBBottom,
  59.   ScreenW, ScreenH, FontX,
  60.   FontY, XOff, YOff        : LONG;
  61.   MyPrgName                : STR;
  62.   
  63. FUNCTION OpenGadTools(version:INTEGER) : BOOLEAN;
  64. FUNCTION OpenASL(version:INTEGER) : BOOLEAN;
  65. PROCEDURE CloseGadTools;
  66. PROCEDURE CloseASL;
  67.  
  68. FUNCTION ComputeX(value:INTEGER) : INTEGER;
  69. FUNCTION ComputeY(value:INTEGER) : INTEGER;
  70. PROCEDURE ComputeFont(VAR f        : p_TextFont;
  71.                       width,height : INTEGER);
  72. PROCEDURE SensitivGadget(VAR ng:NewGadget);
  73. PROCEDURE FS_BevelBox(VAR wo   : p_Window;
  74.                       VAR vi   : PTR;
  75.                              x,y,b,h  : INTEGER;
  76.                              recessed : BOOLEAN);
  77. PROCEDURE GadSelect(VAR wp:p_Window; VAR gad:p_Gadget);
  78. PROCEDURE SetCheckBox(VAR wp:p_Window; VAR gad:p_Gadget; req:p_Requester;
  79.                       flag:BOOLEAN);                             
  80. PROCEDURE SetMXGad(VAR wp:p_Window; VAR gad:p_Gadget; req:p_Requester;
  81.                    active:LONG);                              
  82. PROCEDURE SetCycleGad(VAR wp:p_Window; VAR gad:p_Gadget; req:p_Requester;
  83.                       active:LONG);                              
  84. PROCEDURE SetListViewGad(VAR wp:p_Window; VAR gad:p_Gadget; req:p_Requester;
  85.                          active,top:LONG);                              
  86. PROCEDURE SetListViewList(VAR wp:p_Window; VAR gad:p_Gadget; req:p_Requester;
  87.                           VAR NeueList : p_List);                              
  88. PROCEDURE SetNumberGad(VAR wp:p_Window; VAR gad:p_Gadget; req:p_Requester;
  89.                           nummer:LONG);                              
  90. PROCEDURE GhostGadget(VAR wp:p_Window; VAR gad:p_Gadget; req:p_Requester;
  91.                       dis:BOOLEAN);                              
  92. PROCEDURE ActStringGad(VAR wp:p_Window; VAR gad:p_Gadget; req:p_Requester);
  93. PROCEDURE InitASLStruct(VAR asls : ASLFileStruct);
  94. FUNCTION ASLFileReq(VAR ASLStruct : ASLFileStruct) : LONG;
  95. FUNCTION UserReq(win:p_Window;tit,txt,gad:STR) : LONG;
  96.  
  97. IMPLEMENTATION
  98.  
  99. { Versucht, die "gadtools.library" mit der angegebenen Versionsnummer 
  100.   zu öffnen.                                                      
  101.   
  102.   Eingabe: Mind.-Version
  103.   Ausgabe: TRUE bei Erfolg, ansonsten FALSE                            }
  104. FUNCTION OpenGadTools;
  105. BEGIN
  106.   OpenGadTools := FALSE;
  107.   GadToolsBase := OpenLibrary("gadtools.library", version);
  108.   IF GadToolsBase <> NIL THEN OpenGadTools := TRUE;
  109. END;
  110.  
  111. FUNCTION OpenASL;
  112. BEGIN
  113.   OpenASL := FALSE;
  114.   ASLBase := OpenLibrary("asl.library", version);
  115.   IF ASLBase <> NIL THEN OpenASL := TRUE;
  116. END;
  117.  
  118. { Schliesst die "gadtools.library" }
  119. PROCEDURE CloseGadTools;
  120. BEGIN
  121.   IF GadToolsBase <> NIL THEN CloseLibrary(GadToolsBase);
  122.   GadToolsBase := NIL;
  123. END;
  124.  
  125. PROCEDURE CloseASL;
  126. BEGIN
  127.   IF ASLBase <> NIL THEN CloseLibrary(ASLBase);
  128.   ASLBase := NIL;
  129. END;
  130.  
  131. { Eingabe: Breite bei topaz/8-Font   }
  132. { Ausgabe: Breite bei aktuellem Font }
  133. FUNCTION ComputeX;
  134. BEGIN
  135.   ComputeX := ((FontX * value)+4) DIV 8;
  136. END;
  137.  
  138. { Eingabe: Höhe bei topaz/8-Font   }
  139. { Ausgabe: Höhe bei aktuellem Font }
  140. FUNCTION ComputeY;
  141. BEGIN
  142.   ComputeY := ((FontY*value)+4) DIV 8;
  143. END;
  144.  
  145. PROCEDURE ComputeFont;
  146. LABEL UseTopaz;
  147. BEGIN
  148.   Forbid;
  149.   MyTattr := ^topaz80;
  150.   MyTattr^.ta_Name := f^.tf_Message.mn_Node.ln_Name;
  151.   MyTattr^.ta_YSize := f^.tf_YSize;
  152.   FontY := f^.tf_YSize;
  153.   FontX := f^.tf_XSize;
  154.   Permit;
  155.   IF (width>0) AND (height>0) THEN
  156.   BEGIN
  157.     IF ( (ComputeX(width)+xoff+WBRight)>ScreenW) THEN GOTO UseTopaz;
  158.     IF ( (ComputeY(height)+yoff+WBBottom)>ScreenH) THEN GOTO UseTopaz;
  159.   END;
  160.   EXIT;
  161. UseTopaz:
  162.   MyTattr^.ta_Name := "topaz.font";
  163.   FontX := 8;
  164.   FontY := 8;
  165.   MyTattr^.ta_Flags := FPF_ROMFONT;
  166.   MyTattr^.ta_YSize := 8;
  167. END;
  168.  
  169. { Modifiziert die Koordinaten eines Gadgets so, daß }
  170. {  sie sich fontsensitiv anpassen.                  }
  171. PROCEDURE SensitivGadget;
  172. BEGIN
  173.   ng.ng_LeftEdge := ComputeX(ng.ng_LeftEdge)+xoff;
  174.   ng.ng_TopEdge  := ComputeY(ng.ng_TopEdge)+yoff;
  175.   ng.ng_Width    := ComputeX(ng.ng_Width);
  176.   ng.ng_Height   := ComputeY(ng.ng_Height);
  177. END;
  178.  
  179. { Zeichnet eine (fontsensitive) BevelBox }
  180. PROCEDURE FS_BevelBox;
  181. VAR
  182.   t : ARRAY[1..3] OF TagItem;
  183. BEGIN
  184.   t[1] := TagItem(GT_VisualInfo,LONG(vi));
  185.   t[2] := TagItem(GTBB_Recessed, LONG(recessed));
  186.   t[3].ti_Tag := TAG_DONE;
  187.  
  188.   DrawBevelBoxA(wo^.RPort,
  189.                 xoff+ComputeX(x),
  190.                 yoff+ComputeY(y),
  191.                      ComputeX(b),
  192.                      ComputeY(h),
  193.                      ^t);
  194. END;
  195.  
  196. { Nützliches Feature: Bei gadtools-Gadgets kann man per
  197.   GT_Underscore einen Buchstaben im Gadget-Text unter-
  198.   streichen. Dies soll ja bekanntlich signalisieren,
  199.   daß man durch Drücken dieses unterstrichenen Buchsta-
  200.   bens das Gadget auswählen kann. Um dies "sichtbar" zu
  201.   machen, sollte das Gadget beim Drücken der Taste inver-
  202.   tiert werden, und beim Loslassen wieder im "normalen"
  203.   Zustand gebracht werden.
  204.   
  205.   Eingabe: Das Fenster, wo es selektiert werden soll und
  206.            das Gadget (logisch !)                           }
  207. PROCEDURE GadSelect;
  208. VAR
  209.   next        : p_Gadget;
  210.   old         : LONG;
  211.   dummy       : BOOLEAN;
  212.   class, code : LONG;
  213.   msg         : p_IntuiMessage;
  214. BEGIN
  215.   old := wp^.IDCMPFlags;
  216.   dummy:=ModifyIDCMP(wp,IDCMP_RAWKEY);
  217.   next := gad^.NextGadget;
  218.   gad^.NextGadget := NIL;
  219.   gad^.Flags := gad^.Flags + SELECTED;
  220.   RefreshGadgets(gad,wp,NIL);
  221.   REPEAT
  222.     msg := p_IntuiMessage(WaitPort(wp^.UserPort));
  223.      msg := GT_GetIMsg(wp^.UserPort);
  224.      class := msg^.Class;
  225.      code  := msg^.Code;
  226.      GT_ReplyIMsg(msg);
  227.   UNTIL (class = IDCMP_RAWKEY) AND ( (code AND IECODE_UP_PREFIX)=IECODE_UP_PREFIX);
  228.   dummy:=ModifyIDCMP(wp,old);
  229.   gad^.Flags := gad^.Flags - SELECTED;
  230.   RefreshGadgets(gad,wp,NIL);
  231.   gad^.NextGadget := next;
  232. END;
  233.  
  234. { CheckBox-Gadget an- bzw. ausschalten.
  235.     
  236.   Eingabe: Fenster, das Gadget und - wenn nötig - der
  237.            Requester, auf dem das Gadget "liegt"      }
  238. PROCEDURE SetCheckBox;
  239. VAR
  240.   t : ARRAY[1..2] OF TagItem;
  241. BEGIN
  242.   t[1] := TagItem(GTCB_Checked, ORD(flag));
  243.   t[2].ti_Tag := TAG_DONE;
  244.   GT_SetGadgetAttrsA(gad, wp, req, ^t);
  245. END;
  246.  
  247. PROCEDURE SetMXGad;
  248. VAR
  249.   t : ARRAY[1..2] OF TagItem;
  250. BEGIN
  251.   t[1] := TagItem(GTMX_Active, active);
  252.   t[2].ti_Tag := TAG_DONE;
  253.   GT_SetGadgetAttrsA(gad,wp,req,^t);
  254. END;
  255.  
  256. PROCEDURE SetCycleGad;
  257. VAR
  258.   t : ARRAY[1..2] OF TagItem;
  259. BEGIN
  260.   t[1] := TagItem(GTCY_Active, active);
  261.   t[2].ti_Tag := TAG_DONE;
  262.   GT_SetGadgetAttrsA(gad,wp,req,^t);
  263. END;
  264.  
  265. PROCEDURE SetListViewGad;
  266. VAR
  267.   t : ARRAY[1..3] OF TagItem;
  268. BEGIN
  269.   t[1] := TagItem(GTLV_Selected, active);
  270.   t[2] := TagItem(GTLV_Top, top);
  271.   t[3].ti_Tag := TAG_DONE;
  272.   GT_SetGadgetAttrsA(gad,wp,req,^t);
  273. END;
  274.  
  275. PROCEDURE SetListViewList;
  276. VAR
  277.   t : ARRAY[1..2] OF TagItem;
  278. BEGIN
  279.   t[1] := TagItem(GTLV_Labels, LONG(NeueList));
  280.   t[2].ti_Tag := TAG_DONE;
  281.   GT_SetGadgetAttrsA(gad,wp,req,^t);
  282. END;
  283.  
  284. PROCEDURE SetNumberGad;
  285. VAR
  286.   t : ARRAY[1..2] OF TagItem;
  287. BEGIN
  288.   t[1] := TagItem(GTNM_Number, nummer);
  289.   t[2].ti_Tag := TAG_DONE;
  290.   GT_SetGadgetAttrsA(gad,wp,req,^t);
  291. END;
  292.  
  293. PROCEDURE GhostGadget;
  294. VAR
  295.   t : ARRAY[1..2] OF TagItem;
  296. BEGIN
  297.   t[1] := TagItem(GA_Disabled, ORD(dis));
  298.   t[2].ti_Tag := TAG_DONE;
  299.   GT_SetGadgetAttrsA(gad,wp,req,^t);
  300. END;
  301.  
  302. PROCEDURE ActStringGad;
  303. VAR
  304.   dummy : BOOLEAN;
  305. BEGIN
  306.   dummy := ActivateGadget(gad,wp,req);
  307. END;
  308.  
  309. PROCEDURE InitASLStruct;
  310. BEGIN
  311.   asls := ASLFileStruct(-1,-1,-1,-1,"","","","","","","",TRUE,NIL,FALSE,FALSE,
  312.                         "","");
  313. END;
  314.  
  315. FUNCTION ASLFileReq;
  316. VAR
  317.   t : ARRAY[0..12] OF TagItem;
  318.   fre : p_FileRequester;
  319.   bool : BOOLEAN;
  320. BEGIN
  321.   ASLFileReq := 0;
  322.   t[0].ti_Tag := ASLFR_InitialDrawer;
  323.   IF ASLStruct.initp <> "" THEN t[0].ti_Data := LONG(^ASLStruct.initp)
  324.                            ELSE t[0].ti_Tag := TAG_IGNORE;
  325.   t[1].ti_Tag := ASLFR_InitialFile;
  326.   IF ASLStruct.initd <> "" THEN t[1].ti_Data := LONG(^ASLStruct.initd)
  327.                            ELSE t[1].ti_Tag := TAG_IGNORE;
  328.   t[2] := TagItem(ASLFR_Window, LONG(ASLStruct.win));
  329.   IF ASLStruct.win <> NIL THEN t[2] := TagItem(ASLFR_SleepWindow, ORD(ASLStruct.winsleep))
  330.                           ELSE t[2].ti_Tag := TAG_IGNORE;
  331.   t[3] := TagItem(ASLFR_TitleText, LONG(^ASLStruct.titel));
  332.   IF ASLStruct.pattern <> "" THEN
  333.   BEGIN
  334.     t[4] := TagItem(ASLFR_InitialPattern, LONG(^ASLStruct.pattern))
  335.   END ELSE
  336.   BEGIN
  337.     t[4].ti_Tag := TAG_IGNORE;                    
  338.   END;
  339.   IF ASLStruct.display_pat THEN
  340.      t[5] := TagItem(ASLFR_DoPatterns, ORD(TRUE))
  341.   ELSE
  342.      t[5].ti_Tag := TAG_IGNORE;          
  343.      
  344.   IF ASLStruct.left > -1 THEN t[6] := TagItem(ASLFR_InitialLeftEdge, ASLStruct.left)
  345.                          ELSE t[6].ti_Tag := TAG_IGNORE;
  346.   IF ASLStruct.top > -1 THEN t[7] := TagItem(ASLFR_InitialTopEdge, ASLStruct.top)
  347.                          ELSE t[7].ti_Tag := TAG_IGNORE;
  348.   IF ASLStruct.width > -1 THEN t[8] := TagItem(ASLFR_InitialWidth, ASLStruct.width)
  349.                          ELSE t[8].ti_Tag := TAG_IGNORE;
  350.   IF ASLStruct.height > -1 THEN t[9] := TagItem(ASLFR_InitialHeight, ASLStruct.height)
  351.                          ELSE t[9].ti_Tag := TAG_IGNORE;
  352.                                  
  353.   IF ASLStruct.negativ <> "" THEN
  354.     t[10] := TagItem(ASLFR_NegativeText, LONG(^ASLStruct.negativ))
  355.   ELSE
  356.     t[10].ti_Tag := TAG_IGNORE;
  357.  
  358.   IF ASLStruct.positiv <> "" THEN
  359.     t[11] := TagItem(ASLFR_PositiveText, LONG(^ASLStruct.positiv))
  360.   ELSE
  361.     t[11].ti_Tag := TAG_IGNORE;
  362.      
  363.   t[12].ti_Tag := TAG_DONE;
  364.   
  365.   fre := AllocASLRequest(ASL_FileRequest, ^t);
  366.   IF fre <> NIL THEN
  367.   BEGIN
  368.      IF ASLRequest(fre, ^t) THEN
  369.      BEGIN
  370.        ASLStruct.pfad := fre^.rf_Dir;
  371.         ASLStruct.datei := fre^.rf_File;
  372.         ASLStruct.canceled := FALSE;
  373.         ASLStruct.filename := ASLStruct.pfad;
  374.         bool := AddPart(ASLStruct.filename,ASLStruct.datei,256);
  375.         ASLStruct.pattern := fre^.rf_Pat;
  376.         ASLStruct.initp := ASLStruct.pfad;
  377.         ASLStruct.initd := ASLStruct.datei;
  378.      END ELSE
  379.      BEGIN
  380.         IF IOErr = 0 THEN ASLStruct.canceled := TRUE
  381.         ELSE
  382.         BEGIN
  383.           ASLStruct.canceled := FALSE;
  384.           ASLFileReq := IOErr;
  385.         END;
  386.     END;
  387.      FreeASLRequest(fre);
  388.   END ELSE ASLFileReq := FREQ_NOTALLOC;
  389. END;
  390.  
  391. PROCEDURE GetPrgName;
  392. TYPE
  393.   BCPLStrPtr = ^BCPLStr;
  394.   BCPLStr = ARRAY[0..MaxByte] OF CHAR;
  395. VAR
  396.   MyTask : p_Task;
  397.   MyProc : p_Process;
  398.   ThisCli : p_CommandLineInterface;
  399.   ThisName : BCPLStrPtr;
  400.   tn : BCPLStr;
  401.   name : STRING[256];
  402.   s : STR;
  403. BEGIN
  404.   MyTask := FindTask(NIL);
  405.   MyProc := p_Process(MyTask);
  406.   ThisCli := PTR(4*MyProc^.pr_Cli);
  407.   ThisName := BCPLStrPtr(4*ThisCli^.cli_CommandName);
  408.   tn := ThisName^;
  409.   s := STR(^TN[1]);
  410.   name := s;
  411.   name[ord(TN[0])+1]:=CHR(0);
  412.   MyPrgName := name;      
  413. END;
  414.  
  415. FUNCTION UserReq;
  416. VAR
  417.   es : EasyStruct;
  418. BEGIN
  419.   es := EasyStruct(SizeOf(EasyStruct),0,tit,txt,gad);
  420.   UserReq := EasyRequestArgs(win,^es,NIL,NIL);
  421. END;
  422.  
  423. BEGIN
  424.   topaz80 := TextAttr("topaz.font", 8, 0, 0);
  425.   GetPrgName;
  426. END.
  427.